home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 4
/
Apprentice-Release4.iso
/
Languages
/
Mops 2.7
/
Mops ƒ
/
Class
< prev
next >
Wrap
Text File
|
1995-12-05
|
65KB
|
2,481 lines
\ High-level class/object implementation.
cr .( loading Class...)
\ Note that the object header format is documented at "object building"
\ below.
\ June 91 mrh Moved indexed methods from Object to Indexed-obj in Struct.
\ Added BIND_WITH.
\ May 92 mrh Added [] as synonym for **
\ Apr 94 mrh (Mops 2.5) Added several features:
\ Naming of ivars pushing their address.
\ Temp (local) objects
\ record{ ... } replacing general/non-general distinction.
\ classinit: now sent to all superclasses.
\ msg: super> aSuper
\ Feb 95 mrh Added static and public ivars.
\ Apr 95 mrh Allowed static ivars to also be public. Added class_as>.
\ You want documentation? Here you are!!
\ Here are all our various class/object formats:
(* ================= Object header ======================
Note if the obj is an ivar, it doesn't have a header if it's in a record,
unless the ivar is indexed. Indexed ivars always have headers, no matter
what, since the indexing code relies on it.
2 bytes Offset to the indexed area, rel to the class pointer
(which follows). If not indexed, this will be 6.
4 bytes Class pointer (relocatable).
2 bytes Offset from the data start to the class pointer.
For simple objects (i.e. not embedded), this is -6.
For embedded objects, it will be more negative. Note it
will always be negative.
(object's data starts here)
For indexed objects, the indexed area (after the ivars) is preceded by
the indexed descriptor (xdesc) with this format:
2 bytes Width of indexed elements (in bytes)
4 bytes Number of elements minus 1 (i.e. LIMIT-1).
The low word of this is used by a CHK instruction
if #elements is < 32K.
If indexing is attempted on a non-indexed object, the "offset to the
indexed area" will be 6, taking us to the beginning of the object's
data. The CHK instruction will be done at offset -2 from there, which
won't be the #elements, of course, but will be the offset to the
class pointer WHICH IS ALWAYS NEGATIVE!! Thus the CHK will always fail!
This was a deliberate trick - about the only place in Mops I've
resorted to anything like this, you'll be glad to know.
============== Class dictionary entry ================
link/name as for normal words
4 bytes call to BLD - the word which builds an object
4 bytes link to methods chain (relative)
4 bytes link to ivar chain (relative)
2 bytes non-indexed data length
2 bytes width of indexed elements, or zero if not indexed
2 bytes flags
4(n+1) bytes N-way to superclasses (n relocatable addrs terminated by zero)
Flag bits:
bit 0 "large" - indexed with > 64K elements.
bit 1 class is exported from a module
============== ivar dictionary entry ================
4 bytes hashed name
4 bytes link to prev ivar dic entry (relative addr)
4 bytes class pointer (relocatable)
2 bytes offset of this ivar's data from the base addr of the class
2 bytes number of elements if indexed, or zero if not
2 bytes flags
Flag bits: (zero is rightmost - what will we do on PowerPC?)
bit 0 1 = ivar gets an object header
bit 1 1 = this is a static ivar
bit 2 1 = this is a public ivar
Note: although indexed objects can have 2^^32 elements, we are
assuming that an ivar can't have more than 64K elements. This is
because we are limiting the maximum ivar length of a class to 64K bytes,
which is a stricter condition. Would anybody want a longer ivar than
this??
============== Method dictionary entry ================
4 bytes hashed name
4 bytes link to prev method dic entry (relative addr)
2 bytes flags
Flag bits:
bit 0 1 = private method (note other way round to ivars - we're using
1 for the unusual case)
bit 7 1 = there's a callFirst and/or callLast method
==========================================================
*)
: xx db ; \ useful!
0 value PUB/PRIV \ -1 private, 1 public, 0 default - for ivars and methods
false value STATIC? \ true if following ivars are to be static
0 value ^CLASS \ addr of the class we're currently compiling
0 value PIVAR \ hashed name of any public ivar we're accessing
0 value PIVSEL \ hashed selector of any msg being sent to
\ to a public ivar
0 value NEWOBJECT \ addr of object being created
0 value #SUP \ number of superclasses for current class
0 value SUPERS_TO_SKIP
0 value INITID
\ ===============================
\ UTILITY WORDS
\ ===============================
: PRIVATE -1 -> pub/priv ; \ following methods and ivars will be private
: PUBLIC 1 -> pub/priv ; \ following methods and ivars will be public
: END_PRIVATE 0 -> pub/priv ; \ back to the default
: END_PUBLIC 0 -> pub/priv ; \ ditto
: X bld 123 ; \ The 123 blocks optimization!
' x @ forget x constant CLASSMK \ JSR bldVec-base(A3)
: EXBASE $ 4E92 w, ; immediate \ JSR (A2)
: >OBJ ( cfa -- ^obj ) inline{ 8 +} 8 + ;
: OBJ> ( ^obj -- cfa ) inline{ 8 -} 8 - ;
\ Note: we don't use >class here, since obj> shouldn't be
\ used for embedded objects, and it is used during obj
\ building when the ^class isn't there yet.
: CHKCLASS \ ( cfa -- cfa )
class? ?EXIT
.id space true ?error 80 ;
: ?>CLASS ( ^obj -- ^class )
>class dup 0= ?error 81 ; \ If no legal class ptr, probably
\ not an obj addr at all!
\ the following offsets refer to where a ^class points, i.e. the cfa
\ of the class.
: MFA inline{ 4 +} 4 + ; \ Methods link
: IFA inline{ 8 +} 8 + ; \ ivar link
: DFA inline{ 12 +} 12 + ; \ Data len (2 bytes),
\ width of indexed elts (2 bytes)
: FFA inline{ 16 +} 16 + ; \ Flags
: SFA inline{ 18 +} 18 + ; \ Superclass N-way pointer
: GETDLEN \ ( ^obj -- n ) Gets length of object's named ivars
?>class dfa w@ ;
: (^DLEN) \ ( ^obj -- ^datalen ) This is a low-level word which should
\ normally only be used in the Mops system stuff. Note it
\ takes ^obj, not ^class, and it doesn't do a module check
\ - it assumes the class is in the same segment as the object.
?>class dfa ;
: DLEN&XWID \ ( ^class -- dlen xwid )
?>classInMod
dfa dup w@ swap 2+ w@
?unHoldMod ;
: DLEN dlen&xwid drop ;
: XWID dlen&xwid nip ;
: IVARLEN postpone dlen ; immediate \ an alias for dlen
: ?>MAINDIC { ^class -- '^class }
\ If ^class is exported from a module, we return the main dic
\ equivalent. If it's not exported, we return it unchanged.
\ We need this word since for exported classes, we need to use the
\ imported address (in the main dictionary) as the class pointer
\ in a new object or an ivar dic entry (so that the module will be
\ invoked properly when a method is sent to the object.
^class ffa 1+ 1 btest
IF ^class >name n>count sfind drop
ELSE ^class
THEN ;
: FINDM { selID ^cl -- offs cfa } \ Finds a method in a class.
^cl ?>classInMod -> ^cl
^cl -> objClass
selID ^cl 4 (findm)
NIF cr ^cl .id 108 die ( method not found ) THEN ;
: IVFINDM \ ( selID ^ivar -- cfa base-offs )
\ Looks for a method in an ivar.
\ Note we return the results the other way around to
\ objFindM, since this is what we usually want here.
8 + @abs ( addr of ivar's class ) findm swap ;
: SEND { ^obj selID \ svMB -- } \ Executes a method given its sel ID. Used in
\ late binding. Can also be used if you
\ have a dynamically determined method ID.
modBase -> svMB
selID ^obj objFindM ex-method
svMB -> modBase ;
: (DEFER) ( ^obj -- ) \ Looks up SelID at IP and runs the method.
\ Used in late binding.
@(ip) send ;
0 -> quitvec 0 -> abortvec 0 -> objInit \ clear vectors
' pfind -> ufind
: ?CLASS \ Error if not compiling a class definition.
cstate 0= ?error 115 ;
\ IVFIND is called when we've parsed a selector. It determines if the next
\ word is an ivar.
\ Note: if found, (findm) returns the equivalent of the cfa of
\ a method, which for ivars, is the addr of the class pointer.
: IVFIND \ ( str-addr -- offs ^ivar T | -- str-addr F )
cstate NIF false EXIT THEN
hash
^class 8 (findm)
IF 8 - true ELSE here false THEN ;
\ TOfind looks for a temp (local) object.
: TOfind \ ( str-addr -- cfa T | -- str-addr F )
tmpObjs NIF false EXIT THEN
hash
tmpObjs 8 (findm)
IF 8 - true ELSE here false THEN ;
(*
LocFind will be called from Ufind, which is the vector that gets first
shot at recognizing a word.
It looks at all the possibilities involving local names, which are
not in the regular dictionary. These possibilities are: named parms/locals,
local objects, and if a class is being compiled, ivars of this class.
In the latter case, we arrange for the ivar's address to
be pushed at run time simply by compiling ^base followed by an add of the
ivar's offset - our code generation will produce optimal code for this.
We then have to return the xt of some word to keep FIND happy - we don't
need to compile anything else, so we use the xt of NULL and return a 1
instead of True - this makes FIND think it's immediate. So NULL is
executed immediately, which does precisely nothing.
The one exception to this is if the "ivar" turns out to be SELF or SUPER
- in this case we need to call the nucleus word SELF which works out
the right base address (this is what happened pre-2.5). Here we keep
FIND happy by pushing the xt of SELF and True, so that it sees we've
found SELF.
*)
: LocFind \ ( str-addr -- cfa T | -- str-addr F )
Pfind ?dup ?EXIT \ Found a named parm/local
TOfind
IF \ Found temp obj
drop \ Don't need its dic addr
postpone locReg postpone literal postpone +
['] null 1 EXIT
THEN
\ Now we look for an ivar name
cstate NIF false EXIT THEN \ search fails if we're not compiling
\ a class
dup hash ^class 8 (findm)
IF \ Found ivar
drop nip \ Don't need its dic addr or str addr
dup $ FFFE >= \ is it SELF or SUPER ?
IF drop ['] self true EXIT
THEN
postpone ^base postpone literal postpone +
['] null 1
ELSE false
THEN ;
: ILFA ( infa -- ilfa ) 4+ ;
: ^ICLASS ( infa -- ^class | 0 )
8 + dup @ NIF drop 0 ELSE @abs ?>classInMod THEN ;
: IOFFS ( infa -- ioffs ) 12 + w@ ;
: I#ELS ( infa -- #els ) 14 + w@ ;
: IFFA ( infa -- iffa ) inline{ 16 +} ;
: LASTIVAR? \ ( infa -- infa b ) True if nfa is super or self.
\ These are distinguished by having an "offset" of
\ $ FFFE and $ FFFF respectively.
dup @ 0> IF false EXIT THEN
\ If there's an Nway for superclasses there, then it can't
\ be super or self.
dup 12 + w@ $ FFFE >= ;
\ Otherwise it's a normal ivar dic entry, so we grab the
\ offset field and test it.
: ^NEXTIVAR \ ( infa -- infa' )
ilfa displace ;
forward INITIVAR \ Performs the classinit: method on the ivar on the stack
\ ========================
\ BINDING
\ ========================
0 value OBJ_BASE
0 value OBJ_DISPL
0 value OBJ_LOCAL_DISPL
0 value OBJ_IND
false value SELF?
: OBJ \ Called from within an inline method. Passes the object's
\ base and displacement to Handlers to generate the correct
\ address. Optimization will then apply.
obj_base obj_displ
obj_ind genaddr
obj_local_displ postpone literal postpone + ; immediate
: IX \ Also called from within an inline method.
\ Compiles code to generate the indexed address.
^class dlen&xwid swap
self?
IF drop -1 ELSE 6 + THEN
obj_base obj_displ obj_local_displ obj_ind ^class ffa w@
genxaddr ; immediate
local EARLY_BIND { oCfa oBase oDispl oLDispl oind slf? -- }
: INL_BIND \ ( -- b )
\ In-line code to be compiled for this method.
\ But note, we don't do it if obj_base is zero, meaning that
\ we have put the ^obj in A0 as a temporary. Some inline
\ methods could cause a clash on A0. So in this case we
\ call the out-of-line code - we return true so that this
\ will be done by NORM_BIND. Otherwise we return false.
obj_base
NIF \ Update cfa to the out-of-line code
oCfa 2+ dup c@ + aligned -> oCfa true
ELSE
^class cstate self? \ Save over upcoming evaluate
slf? NIF objClass -> ^class THEN \ Set ^class and cstate
true -> cstate \ so ivars are accessible
slf? -> self?
oCfa (compinl)
-> self? -> cstate -> ^class \ Restore
false
THEN ;
: NORM_BIND
oCfa postpone obj EB ;
:loc EARLY_BIND \ { oCfa oBase oDispl oLDispl oind slf? -- }
obj_base obj_displ obj_local_displ obj_ind \ Save
oBase -> obj_base oDispl -> obj_displ
OLdispl -> obj_local_displ oind -> obj_ind
oCfa w@ inlMk =
IF inl_bind ELSE true THEN
IF norm_bind THEN
-> obj_ind -> obj_local_displ
-> obj_displ -> obj_base \ Restore
;loc
: BIND_TO_OBJ \ ( cfa ^obj -- )
-1 swap 0 0 false early_bind ;
: BIND_TO_STK \ ( cfa -- )
stkObj 0 swap false early_bind ;
: BIND_TO_IVAR { cfa offs -- }
cfa obj_base obj_displ
obj_local_displ offs +
obj_ind false early_bind ;
: BIND_TO_TMPOBJ { cfa offs -- }
cfa 4 offs
0 0 false early_bind ;
: BIND_TO_SELF { cfa offs -- }
cfa obj_base obj_displ offs obj_ind true early_bind ;
\ ===========================
\ INITIALIZING NEW OBJECTS
\ ===========================
0 value ^XDESC \ Used in the setting up of an index descriptor
0 value OFFS \ Used in setting up ivars
false value REC? \ Are we compiling a record?
false value UNION? \ Are we compiling a union in a record?
0 value UNIONOFFS \ Base offset of the current union
: ?HDRS { thisClass ^data infa \ xw flags -- }
\ For normal ivars, this word sets up the object headers - namely
\ ^class, ^class offset, xoffs and xdesc. But if we're in a record,
\ non-indexed ivars don't have an object header.
thisClass 0EXIT \ out if self or super
infa iffa w@ -> flags
flags 1 and 0EXIT \ out if ivar not flagged as needing a header
flags 2 and ?EXIT \ out if it's static (doesn't live in the
\ object at all)
\ OK, we need the headers. Let's set 'em up:
thisClass ?>maindic
false -> relocChk?
^data 6 - reloc! \ ^class (safe if outside a module
true -> relocChk? \ here, since ivars of an obj belonging
\ to an exported class can only be
\ accessed while the module is running)
-6 ^data 2- w! \ ^class offset
thisClass xwid -> xw
xw NIF \ Not indexed: store dummy xoffs
6 ^data 8 - w! EXIT \ and we're done.
THEN
thisClass dlen aligned \ Indexed:
dup 12 + ^data 8 - w! \ xoffs
^data + -> ^xdesc
xw ^xdesc w! \ xdesc
infa i#els 1- ^xdesc 2+ ! ; \ #elements
forward IVSETUP
: NW_IVSETUP { ^nway boffs EOoffs
\ initEOoffs svHeldMod thisClass ^slf totalOffs -- }
\ Sets up the groups of ivars for each superclass, for a multiply inherited
\ object. Each group we call an "embedded object", which sort of describes
\ what it is.
\ ^nway points to the current superclass pointer in the n-way defining the
\ multiple inheritance. boffs is the base offset from newObject, the actual
\ top-level (non-ivar) object being created. EOoffs is the extra offset to
\ the current embedded object. When an embedded object starts at a non-zero
\ EOoffs, we put in front of it a 2-byte offset to the class pointer. Note
\ that if the multiply inherited object is an ivar, there may not be a class
\ pointer! This doesn't matter, since it's better for multiply inherited
\ objects to always have the same format, wherever they are, and any attempt
\ to use the class pointer offset to get the (nonexistent) class pointer
\ will most probably be caught by our checks.
\ With Mops 2.5 we're now sending classinit: separately to each superclass.
EOoffs -> initEOoffs
BEGIN
^nway @abs ?>classInMod -> thisClass \ may hold a mod
boffs EOoffs + initEOoffs - -> totalOffs
thisClass ifa displace totalOffs EOoffs ivSetup
\ now we send Classinit:
thisClass -> objClass
initID thisClass 4 (findm) \ ( -- offs cfa T | F )
IF swap newObject + totalOffs + swap ex-method THEN
?unholdMod \ now finished with the mod
1cell ++> ^nway
^nway @
WHILE \ another class coming up - store 2-byte ^class offset first
thisClass dlen ++> EOoffs
EOoffs aligned -> EOoffs
EOoffs negate 8 - \ ^class offset for store
EOoffs initEOoffs - \ offset not already included in boffs
boffs + newObject + \ final addr for store
w!
2 ++> EOoffs
REPEAT ;
:f IVSETUP { infa boffs EOoffs \ svHeldMod thisClass ^data -- }
\ Recursively traverses the tree of nested ivar definitions in a class,
\ building the necessary ^class offsets and indexed area headers.
\ infa is the nfa of the current ivar, and boffs is the current base offset
\ for ivars at this point in the nested ivar structure, relative to newObject,
\ the current top-level object being created.
\ When this word is called, if thisClass is in a module, the module will
\ be held. In some circumstances the caller still needs it. The
\ recursive call might require another module to be held, so we have to
\ save and restore any module held on entry.
heldMod -> svHeldMod \ save heldMod
0 -> heldMod \ clear it so nobody can unhold
BEGIN
infa @ 0>
IF \ we've hit a superclass n-way
infa boffs EOoffs NW_ivSetup \ set up superclasses
svHeldMod -> heldMod EXIT \ restore heldMod, and out
THEN
infa lastivar? nip
IF \ no more ivars
svHeldMod -> heldMod EXIT \ restore heldMod, and out
THEN
infa iffa w@ 2 and \ static ivars don't live in the object
NIF
infa ^iclass -> thisClass \ may hold another mod
infa ioffs -> offs \ relative offs of this ivar
boffs offs + newObject + -> ^data
\ First we do a recursive call to set up the
\ (nested) ivars of this ivar's class.
?Rdepth \ Check on recursion depth
infa ^iclass ifa displace \ infa of last nested ivar
( newNfa ) offs boffs + \ New base offset
0
ivSetup \ Recursive call to set up this ivar
?unHoldMod \ unhold any held mod
thisClass ^data infa ?hdrs \ Add headers if nec
boffs infa initivar \ Initialize by calling Classinit:
THEN
infa ^nextivar -> infa \ Step to next ivar and loop.
AGAIN ;f
forward CLASSINIT \ Will be classinit: newObject - once we can send
\ messages
\ HASHED-HDR lays down the dic header for an ivar or method.
\ The format is:
\
\ 4 bytes hash
\ 4 bytes link (self-relative addr of prev entry)
\
\ This entry has to become the first on the chain, so we pass in the
\ addr of the chain header.
: HASHED-HDR \ ( chain-hdr hash-val -- )
, \ comma in hash value
dup displace \ get abs addr of prev entry
displ, \ comma it in as self-relative addr
here 8 - swap displ! \ update chain header
;
forward DIC-OBJ
: IVDEF ( #els ) { iclass \ #els wid siz clOffs flags -- }
\ Compiles an ivar dictionary entry. If indexed, must have
\ < 64K elements. iclass is the ivar's class. The class of
\ which this is an ivar, is pointed to by ^class.
pub/priv 1 = 4 and -> flags \ initial flags - set bit 2 if we're public
Mword
ivFind ?error 117 \ same name as another ivar
drop
iclass xwid -> wid \ indexed width of ivar class
iclass dlen -> siz \ non-indexed size of this ivar
\ The initial offset is the current dlen of the class.
^class dfa w@ -> clOffs
^class ifa
here hash hashed-hdr \ dic header for ivar
iclass ?>mainDic reloc,
\ Now we need to comma in the 2-byte offset to the ivar within
\ the class. First we need to make some adjustments...
\ Do we need to align the offset:
siz 1 > \ we do if the ivar size is longer than 1
wid rec? not and \ or if it's indexed, and we're not in a record
or
IF \ We do need to align the offset. Note that if the
\ ivar class is multiply inherited with >1 superclass
\ of non-zero length, the ivar size will always be >1.
clOffs aligned -> clOffs
THEN
iclass ffa 1+ 2 btest \ general?
dup IF union? ?error 190 THEN
\ can't have a general object in a union
rec? not or \ or not in a record?
IF \ Yes. In this case the ivar will have
\ the standard 8-byte object header. So its data
8 ++> clOffs \ will start 8 bytes later than otherwise.
1 or> flags \ and we'll mark this in the ivar flags
\ so ?hdrs will do the right thing.
THEN
clOffs w,
wid
IF \ Indexed. Stack has #els. We calculate the indexed
\ length of this ivar and increment clOffs.
\ If we're not in a record, we also need to align the
\ non-indexed size of the ivar, since the xdesc must
\ be aligned. (If we're in a record, there won't be an
\ xdesc.)
-> #els
rec? NIF siz aligned -> siz THEN
#els w, \ Add #els to ivar dic entry
#els wid * \ Get indexed length
rec? NIF 6 + THEN \ Add 6 for xdesc length
++> clOffs \ Add to clOffs
ELSE \ Not indexed.
0 w,
THEN
static?
IF 2 or> flags
ELSE
siz ++> clOffs \ Bump clOffs by non-indexed size of ivar
THEN
flags w,
(* Now we'll update the class dLen field by whatever we're allocating for this
ivar - it will then be the offset to the next ivar. clOffs has the offset
so far. In the normal case, this is what goes in dLen. If we're in
a union, we MAX it with whatever's already in dLen. This will leave dLen
with the longest union element we've reached so far, which will be the final
value in case we hit the end of the union.
And if this ivar is static, it will live right where we are in the dic,
and not in objects of the class, so in this case we leave dLen alone.
*)
union?
IF unionOffs clOffs max -> unionOffs
ELSE
static?
NIF clOffs ^class dfa w!
THEN
THEN
(* Now we'll check if this ivar is to be static - if so, we'll instantiate
it right here.
*)
static? 0EXIT
wid IF #els THEN
iclass dic-obj
;
\ =================================
\ OBJECT BUILDING
\ =================================
: CL>LEN ( #els ) { theClass \ wid len -- ( #els ) len2 }
\ Gets data length of object given #els and class.
theClass dlen&xwid -> wid -> len
wid IF ( #els ) dup 32766 >
IF theClass ffa 1+ 0 btest 0= ?error 185 then
dup wid * 6 + len +
ELSE len
THEN ;
: MAKE_OBJ ( #els ) { theClass ^obj \ svHeldMod wid len #els -- }
0 -> #els
theClass ?>classinMod -> theClass
heldMod -> svHeldMod 0 -> heldMod \ So dlen&xwid doesn't unhold
theClass dlen&xwid -> wid -> len
\ Now if there's an indexed width, we set up xdesc, the indexed descriptor
wid
IF -> #els len aligned -> len
^obj len + -> ^xdesc \ It's after the ivars, and aligned
wid ^xdesc w! #els 1- ^xdesc 2+ !
len 12 +
ELSE 6
THEN
\ Now for the object header.
^obj obj> w!
-6 ^obj 2- w!
theClass ?>mainDic
^obj 6 -
false -> relocChk? reloc! \ obj addr could be in the heap!
true -> relocChk?
^obj -> newObject
theClass ifa displace 0 0 ivSetup
svHeldMod -> heldMod ?unholdMod
\ Lastly we send classinit: to the object. Note ivSetup has already
\ sent classinit: to each superclass.
classinit ;
:f DIC-OBJ ( #els ) { theClass \ ^obj -- }
\ Builds an object in the dictionary.
here >obj -> ^obj \ Where obj data will start
theClass cl>len
8 + aligned \ Required length
dup room > ?error 186 \ "Not enough room"
reserve \ Allocate space for object
theClass ^obj make_obj \ Set up the object
align-dp ;f
0 value THECLASS
:f BLD \ ( (#els) -- ) Builds an object.
r> 4- -> theClass
cstate
IF theClass ivDef \ Build an ivar
ELSE create_obj \ Create object header - returns
\ its data address when called
theClass dic-obj
THEN ;f
: ]C true -> cstate ; immediate
: C[ false -> cstate ; immediate
: HASH, \ Compiles hashed word for name at here
@word hash , ;
\ ============================
\ :CLASS etc.
\ ============================
\ Here we set up some quantities so that we can send messages to SELF
\ or SUPER. These are treated syntactically as ivars, so to implement
\ them we actually set up dummy ivars SELF and SUPER.
\ When we're processing a :CLASS definition, we plug the appropriate
\ addresses into these ivars. ^SELF is a word defined to return the
\ addr of the dummy ivar SELF, so we can do the plugging.
\ In the case of SUPER, there may be several superclasses, so we have
\ to go through a class descriptor, since that's the only place we look
\ for an n-way (a set of addresses). So we set the "class" of SUPER
\ to a dummy class SUPCL, which has no ivars or methods (so the search
\ will pass right on by), and plug the superclass pointer of SUPCL to
\ point to the current n-way for the superclasses of the class we're
\ defining.
0 value (^SELF)
: ^SELF ['] (^self) displace ;
create SUPCL \ dummy superclass
classCode here 2 - w!
classMk ,
0, \ methods link - no methods
0, \ ivar link - patched at :CLASS time
\ META is the super class of Object - top of all inheritance
: META reveal
[ \ Note, we're still at the cfa
drop \ Drop the security marker left by colon
classCode here 2 - w!
classMk , \ class marker goes here
0, \ methods link - none as yet
0, \ ivar link - set to SUPER below
0, \ data len, flags
0, \ super pointer
\ Now we set up the SELF and SUPER pseudo-ivars. We set them up exactly
\ as if they'd been declared as regular ivars in META. But note we don't
\ set up any fields past the "offset" field, since they're irrelevant.
create SUP \ this is so we can tick it at SuperRef below.
here \ ready for SELF link below
hash, SUPER
0, \ empty link
' supCl reloc, \ ^class is dummy supCl (reloc addr reqd)
$ FFFE w, \ "offset" FFFE means SUPER
here
hash, SELF
swap displ, \ link
0, \ ^class (gets patched at :CLASS time)
$ FFFF w, \ "offset" FFFF means SELF
dup ' (^self) displ!
' meta ifa displ!
0 value THISM
0 value SUPERM
false value 1SUPER?
: :CLASS immediate
?exec header classCode w,
here -> ^class
0 -> pub/priv 0 -> #1st 0 -> #last
false -> rec? false -> union? false -> static?
307 ;
: MERGE_INFO { ^sup ivlen \ ^wid wid prevWid -- dlen }
^sup dlen&xwid -> wid \ indexed width of this superclass
^sup ffa 1+ c@ 5 and \ Merge "general" and "indexed" flags with
^class ffa 1+ cset \ what we have already
wid 0EXIT \ If this superclass not indexed, we're done
\ This class is indexed - we need to check if prev classes were indexed
\ and make sure the widths are compatible.
^class dfa 2+ -> ^wid \ Addr of wid field in class we're building
^wid w@ -> prevWid \ Get previous width
wid 32767 = \ "indexed width" of 32767 really means
IF \ obj_array.
prevWid \ In this case if we already have a width,
IF prevWid -> wid \ we use that,
ELSE ivlen -> wid \ Otherwise current ivar len becomes the width.
THEN
THEN
prevWid
NIF wid ^wid w! \ If no prev width, set width & we're done
ELSE prevWid wid <> ?error 88 \ "Incompatible indexed widths"
THEN ;
local (SUP) { \ ivlen ^nway ^sup thisLen -- }
: NEXT_SUPER ( cfa -- )
chkClass -> ^sup
^sup reloc, \ Add ^class to n-way
^sup ivlen merge_info -> thisLen
#sup IF \ If this is a subsequent class,
ivlen aligned 2+ -> ivlen \ align and allow for ^class offset
THEN
thisLen ++> ivlen \ And add ivar length of new class
1 ++> #sup ;
: SUPERS_LOOP
BEGIN \ Loop over superclasses:
' \ cfa of next item on list
}or)? IF drop EXIT THEN
( cfa ) next_super \ handle next superclass
1super? ?EXIT \ Yerk has only one superclass
AGAIN ;
:loc (SUP)
307 ?pairs \ Make sure we're in the right place
classMk , 14 reserve \ Space for class record
here -> ^nway \ n-way for superclasses will
0 -> ivlen 0 -> #sup \ start here
^nway dup 14 - displ! \ Point methods link here
^nway dup 10 - displ! \ and ivars link
false -> relocChk?
supers_loop \ Loop over superclasses
0, \ Terminate n-way
^nway ['] supCl mfa displ!
ivlen ^class dfa w! \ Set total ivar length
^class ^self 8 + reloc! \ Store ^class in SELF
true -> relocChk?
postpone ]c ( postpone [ ) \ In a class definition
308
;loc
: SUPER{ false -> 1super? (sup) ; immediate
: SUPER( postpone super{ ; immediate
: <SUPER true -> 1super? (sup) ; immediate
\ For compatibility with Yerk -- only looks for 1 superclass
: (;CL)
postpone [ postpone c[
0 ^self 8 + ! ;
: ;CLASS
(;cl) 308 ?defn ; immediate
0 value DFRSELID
true value SLCTRS? \ Set false to treat selectors as normal words
\ for full ANSI compatibility
: SEL? \ ( addr -- addr b ) True if word at addr is a selector xxx:
slctrs? NIF false EXIT THEN
dup count tuck 1- + c@ & : =
swap 1 > and ;
: GETSELECT \ Gets a selector from the input stream
mword
sel? not ?error 124
hash
0 -> dfrSelID ;
' null vect GET1ST&LAST
' null vect DoCall1ST
' null vect DoCallLast
: M_HEADER { selID -- } \ Builds a method header and entry sequence.
\ Note: also called from the assembler.
^class mfa selID hashed-hdr \ Build header
pub/priv -1 = 1 and w, \ plus private flag (default is public)
here -> thisM \ Remember method cfa
Mentry ; \ Compile the entry sequence
: :M { \ selID -- } immediate \ Start compiling a method.
true -> method? \ Used by Handlers
?class 305
rec? ?error 191 \ unmatched '{' in ivar list
0 -> superM
getSelect -> selID
10 -> cstate \ Means we've read :m, no call_1st yet
selID ^class 4 (findm) \ is method already defined?
IF
-> superM
warnings?
IF cr 0 -> out
here count type type# 182 \ "Method redefined"
THEN
heldMod
NIF superM ^class > ?error 183 THEN \ - but if in same class, error
drop
THEN
get1st&last ?unHoldMod
selID m_header \ Build method header
#1st #last + IF thisM 1- 7 bset THEN
2 $ 40 + -> obj_base \ $ 40 indicates A-reg
0 -> obj_displ \ For any inline method calls
:noname \ Start to compile the method
doCall1st ; \ Compile any Call1st calls first
: ;M immediate
(;)
#last IF true -> method? doCallLast defnEnd false -> method? THEN
0 -> #1st 0 -> #last
305 ?defn ;
\ ============== Local sections for methods ==============
\ These function just like regular local sections. The implementation
\ is nearly the same.
0 value MLOC_ADDR
: MLOCAL \ Starts a local section for methods
local? ?error 93 1 -> local? \ We change it to the normal -1
\ as soon as "{" is read.
postpone :m
postpone [
here -> mloc_addr 10 allot \ Like a forward definition. We
\ save the addr to patch and leave
\ room for the JMP instrn which will
\ be planted by (patch) below.
private ;
: :MLOC immediate
public ?loc getSelect drop 95
here mloc_addr (patch) \ Like :F
#PL IF PLentry THEN
false -> local? \ We do this here so any EXITs
\ tidy everything up properly
postpone ] ;
: ;MLOC immediate
(;) 95 ?pairs \ As local? is now false, everything else
305 ?defn ; \ gets tidied up by (;)
\ ================ INDEXED, GENERAL etc. =================
\ These are words which can appear in a class declaration, in the
\ position
\ :class someClass super{ someSuper } general
\ They add attributes to the class.
: INDEXED \ ( width -- ) Sets a class and its subclasses to indexed
?class ^class dfa 2+ w! ;
: LARGE \ Sets the "large" option on an indexed class, allowing
\ the number of elements to be greater than 32K.
?class ^class ffa 1+ 0 bset ;
: GENERAL
(* Sets the "general" option on a class, which will force an ivar of that class
to be a general object with a class pointer (so it can be late-bound to) even
if it's within a record. Normally you should just not put such ivars in a
record, but using GENERAL gives a bit of extra security, for classes for which
you know that they will definitely be late-bound to. (An attempt to late-bind
to an ivar without a class pointer will give the "not an object" error at run
time, which isn't easy to track down.)
Note that indexed classes are always general anyway. Also if there's a message
sent to [self] somewhere in one of the methods, we know that the class *must*
be general, so in this case we simply set the general attribute.
*)
?class ^class ffa 1+ 2 bset ;
\ ===========================
\ SELECTORS
\ ===========================
\ First, here are the special-purpose things which can follow a selector.
\ These can't appear in isolation.
\ We allow ** and [] as synonyms of [ ] to late-bind to whatever is on the
\ stack. Note: [] is used in JForth.
\ We also allow [self] as a synonym of [ self ]
: ** 83 die ; \ "Has no meaning unless preceded by a selector"
: [] 83 die ;
: [SELF] 83 die ;
: SUPER> 83 die ;
: IVAR> 83 die ;
: CLASS_AS> 83 die ;
: ] immediate
hide dfrSelID NIF postpone ] EXIT THEN
state
IF 251 ?pairs postpone (defer) dfrSelID ,
ELSE dfrSelID send
THEN
0 -> dfrSelID ;
100 constant pubIvarTyp \ &&& temp
false value need_class?
false value implicit_late_bind? \ true for pre-2.7 auto-late-bind
\ to locals or values
(* REFTOKEN ( -- cfa tokenType | -- various type )
is called when we've parsed a selector - it determines the type of the
following word.
The order of checking determines the priority of names. Up to 2.6 we
checked for locals first, but this was a bad idea since a local could
have the same name as an object, and implicit late binding to locals
was legal. This wouldn't show up until a crash at run time. So now we
check for temp objects, then ivars, then locals IF implcit_late_bind? is
true.
"various" will be the cfa of whatever came after the selector, or
( offset ^ivar ) for ivars and temp objects (which are treated as ivars
of the class Dummy).
*)
: REFTOKEN \ ( -- cfa tokenType | -- various type )
false -> need_class?
Mword \ grab next word
TOfind IF tmpObjTyp EXIT THEN \ check for temp object
IVfind IF ivarTyp EXIT THEN \ check for ivar
implicit_late_bind?
IF Pfind IF locTyp EXIT THEN \ check for named parm/locals
THEN
( here ) dup thread dup @ + (find) 0= ?error 125
dup ['] ** = IF lbTyp EXIT THEN
dup ['] [] = IF lbTyp EXIT THEN
dup ['] [ = IF bktTyp EXIT THEN
dup ['] [self] = IF lbSelfTyp EXIT THEN
dup ['] super> = IF superTyp EXIT THEN
dup ['] ivar> = IF pubIvarTyp EXIT THEN
dup ['] class_as> = IF true -> need_class? classTyp EXIT THEN
dup hdlr
CASE
objCode OF >obj objTyp ENDOF
classCode OF classTyp ENDOF
-90 OF classTyp ENDOF \ Exported class
objPtrCode OF objPtrTyp ENDOF
valCode OF valTyp ENDOF
wordCode OF wordTyp ENDOF
vectCode OF wordTyp ENDOF
\ Note: here we can treat vectors as words.
126 die \ "Not an object name"
ENDCASE
\ but if we got wordTyp or valTyp, it's only legal if implicit_late_bind?
\ is true
implicit_late_bind? ?EXIT \ all OK - done
dup wordTyp = over valTyp = or
IF 126 die THEN
;
\ These words handle the binding of a selector to whatever follows it.
\ FIX_PIVAR does the housekeeping for accessing a public ivar
: FIX_PIVAR { ^class in_class? \ offs ^ivar -- cfa offs }
pivar ^class 8 (findm) \ ( offs cfa T | F )
0= ?error 192 \ "ivar not found"
swap -> offs 8 - -> ^ivar
^ivar iffa w@ \ get ivar flags
dup 4 and 0= ?error 193 \ ivar not public
2 and \ static flag
in_class?
IF 0= ?error 197 \ ivar not static
ELSE ?error 195 \ wrong syntax for public static ivar
THEN
pivSel ^ivar ivFindM
( cfa loc-offs )
in_class?
IF drop ^ivar 26 +
ELSE
++> offs offs
THEN
;
\ PUBLIC_STATIC_IVAR_REF handles a message bind to a public static ivar
\ (done via the msg: ivar> in_class someClass syntax)
: PUBLIC_STATIC_IVAR_REF
refToken
classTyp <> ?error 196 \ class name must follow in_class
true fix_pivar
bind_to_obj
;
\ OBJREF handles a reference to a normal object.
: OBJREF { selID ^obj \ offs -- }
selID
IF selID ^obj objFindM swap
ELSE \ it's a public ivar reference in the referenced object
^obj >class false fix_pivar ^obj +
THEN
bind_to_obj
;
\ IVARREF handles a reference to an ivar.
: IVARREF { selID offs ^ivar \ stat? -- }
heldMod 0 -> heldMod \ Save
offs $ FFFE >= -> selfRef? \ If self or super. Allows private
\ methods to be found by (findm)
selfRef?
IF supers_to_skip -> sups2skip \ sups2skip is interrogated by (findm).
\ This must only be done if self or
\ super is the target.
ELSE
^ivar iffa w@ 2 and -> stat? \ static ivar?
THEN
selID
IF selID ^ivar ivFindM
0 -> sups2skip 0 -> supers_to_skip
( cfa loc-offs )
selfRef?
IF bind_to_self false -> selfRef?
ELSE
stat?
IF drop ^ivar 26 + bind_to_obj
ELSE
offs + bind_to_ivar
THEN
THEN
ELSE
^ivar ^iclass false fix_pivar
stat?
IF ^ivar 26 + + bind_to_obj
ELSE
offs + bind_to_ivar
THEN
THEN
?unholdMod -> heldMod ;
\ OBJPTRREF handles a reference to an object pointer.
: OBJPTRREF { selID OP-cfa \ ^cl -- }
OP-cfa (comp) \ Compile a fetch of the OP-cfa,
\ giving ^obj at run time
OP-cfa 4+ @ 0= ?error 86 \ "ObjPtr hasn't had a class specified"
OP-cfa 4+ @abs -> ^cl
^cl hdlr -90 =
IF \ Class is exported
^cl 6 + wdisplace \ Addr of module
compmod = ?error 84 \ It's the module we're compiling -
\ this is a no-no, since the ObjPtr
\ reference will use the OLD module!
^cl ?>classInMod -> ^cl
THEN
selID
IF selID ^cl findm swap
ELSE
^cl false fix_pivar
THEN
( cfa offs ) postpone literal postpone + bind_to_stk ;
\ TMPOBJREF handles a reference to a temp object.
: TMPOBJREF { selID offs ^tmpObj \ svHeldMod -- }
heldMod -> svHeldMod 0 -> heldMod
selID
IF selID ^tmpObj ivFindM
ELSE
^tmpObj 8 + @abs false fix_pivar
THEN
( cfa loc-offs )
offs + bind_to_tmpObj
svHeldMod -> heldMod ;
\ CLASSREF handles a reference to a class - this means use the object
\ whose addr is on the stack, but ASSUME it is of the given class
\ and early bind, without checking.
: CLASSREF { selID ^class -- }
need_class? IF ' chkClass -> ^class false -> need_class? THEN
selID
IF selID ^class findm swap
ELSE
^class false fix_pivar
THEN
postpone literal postpone + bind_to_stk
;
\ SuperRef handles the msg: super> someSuper construct.
: SUPERREF { selID \ ^nway namedClass ^nway' cnt -- }
?class \ Must be compiling a class
' -> namedClass \ get named class xt
^class sfa -> ^nway
^nway -> ^nway' 0 -> cnt
BEGIN
^nway' @ 0= ?error 120 \ "superclass" not found
^nway' @abs namedClass =
NWHILE
1cell ++> ^nway' 1 ++> cnt
REPEAT
cnt -> supers_to_skip
selID $ FFFE ['] sup ivarRef \ equivalent to msg: super
;
forward COMPREF
\ PubIvarRef handles the msg: ivar> someIvar IN someObj construct, to
\ send a message directly to a public ivar in an object.
: PUBIVARREF { selID \ addr len ^class ^ivar -- }
selID -> pivSel
mword hash -> pivar
mword count -> len -> addr
addr len " IN" s=
IF 0 \ dummy "selID" for compRef (not a legal selector)
compRef \ handle whatever object comes after IN. The
\ zero selector signals that a public ivar in the
\ indicated object is to be accessed.
ELSE
addr len " IN_CLASS" s=
IF public_static_ivar_ref
ELSE true ?error 194 \ "wrong syntax for public ivar"
THEN
THEN
;
\ LBselfRef handles messages to [self] - i.e. late bound to Self.
: LBSELFREF
postpone self postpone (defer) ,
\ Any class with a late-bound message to self MUST be general. So if
\ we're compling a class (we don't have to be), we'll force it to
\ general!
cstate IF general THEN ;
: COMPDFR \ (selID cfa -- )
(comp) postpone (defer) , ;
\ Now here are the main words which compile the selector bindings.
\ CompRef operates at compile time - it compiles a selector bind.
:f COMPREF \ ( selID -- )
refToken \ ( selID addr type ) - addr is ^obj for objects, otherwise
\ the cfa of whatever came after the selector.
CASE
objTyp OF objRef ENDOF
ivarTyp OF ivarRef ENDOF
objPtrTyp OF objPtrRef ENDOF
tmpObjTyp OF tmpObjRef ENDOF
classTyp OF classRef ENDOF
\ These next 3 can only come up if implicit_late_bind? is true:
valTyp OF compdfr ENDOF
locTyp OF compdfr ENDOF
wordTyp OF compdfr ENDOF
lbTyp OF drop postpone (defer) , ENDOF
lbSelfTyp OF drop LBselfRef ENDOF
bktTyp OF drop -> dfrSelID 251 ENDOF
superTyp OF drop superRef ENDOF
pubIvarTyp OF drop pubIvarRef ENDOF
82 die \ "Selector can't be used on that"
ENDCASE ;f
(*
RunRef is the execution mode equivalent - it executes a selector bind.
We do this simply by compiling it in a buffer then executing it there.
This replaces the earlier scheme where we had to separately handle each
case as for compRef - this was a Neon carryover.
While we're compiling in the buffer, we save the DP on the return stack,
then restore it before executing what we compiled (since it might do some
compiling itself). This isn't long, but it's a bit tricky:
*)
variable runRefBuf 56 reserve \ allows 4 nested binds - worst case
\ 14 bytes each
0 value bufPtr
0 value hiDP
: RUNREF { selID \ svDP svBufPtr svState -- }
DP -> svDP \ save DP
DP hiDP umax -> hiDP \ so we can reset DP to right place on an error
bufPtr NIF runRefBuf ELSE bufPtr THEN
dup -> DP -> svBufPtr \ now we'll compile in runRefBuf
state -> svState \ save state
postpone ] \ need compile state so this compilation works properly
selID compRef \ compile the binding
postpone (exit) \ and an exit, so we return to interpretation
svState -> state \ restore state
0 -> hiDP \ don't need it any more and could cause problems
?unholdMod
DP -> bufPtr \ new bufPtr value
svDP -> DP \ restore DP since the code might compile something
patches_done \ we're about to execute what we just compiled
svBufPtr execute \ execute at old bufPtr location
svBufPtr -> bufPtr \ then restore old bufPtr
;
\ ======== Selector support =========
\ MESSAGE is the handling word invoked by using a selector.
: MESSAGE immediate
state
IF \ Compile state
compRef \ Compile the message send
?unHoldMod
ELSE
runRef \ Run state - execute object/vector reference.
\ ?unHoldMod is called by ex-method at the
\ end, so we don't need to call it here.
THEN ;
\ 1stFind lumps together all the special cases we have to look for after
\ we've parsed an input word, but before we can do a regular dictionary
\ lookup. At present these are selectors, named parms/locals, ivars
\ and local objects. If we invent more later, they can easily be added.
\ The vector Ufind is then set to this word so it is called before the
\ regular dictionary search. If we succeed here, we return the selector
\ ID or zero, the cfa of the handling word, and 1 or -1 (this will cause
\ FIND to exit without doing anything more). If we fail, we return the
\ original string address and false.
: 1stFIND \ ( str-addr -- selID message-cfa T | -- str-addr F )
sel? \ is it a selector?
IF hash \ yes - leave selID
['] message 1 \ and cfa of message, and 1 (it's immediate)
ELSE LocFind \ no - look for the various kinds of local name
THEN ;
' 1stFind -> Ufind
: OBJLEN \ ( -- objlen ) Computes total data length of current object.
^base (^dlen) dup w@ swap 2+ w@ ?dup
IF idxBase 4- @ 1+ * + 4+ THEN ;
:f CLASSINIT newObject classinit: [] ;f
getSelect classinit: -> initID
:f INITIVAR { boffs infa -- }
infa ^iclass 0EXIT \ Don't init self or super
initID infa ivFindM drop
infa ioffs boffs + newObject + \ ( cfa ^data )
swap ex-method ;f \ execute ClassInit:
forward DUMP
\ SET_CLASS is a utility word used to patch nucleus objects when their classes
\ are defined in higher-level files. Actually it could be used to change the
\ class of any object, if anyone is silly enough to want to do that.
\ Usage: fFcb ['] file set_class
: SET_CLASS { ^obj theClass -- }
theClass chkClass ^obj 6 - reloc! \ Patch ^class
6 ^obj 8 - w! \ Not indexed (yet)
-6 ^obj 2- w! ; \ ^class offset
: CHKSAME \ ( ^obj -- ^obj )
\ A check that two objects are of exactly the
\ same class.
dup >classCfa ^base >classCfa <> ?error 87 ;
\ ========= Object pointers ==========
\ Object pointers are low-level objects (like VALUEs) which point to a
\ normal (high-level) object, and which allow early-bound messages to be
\ sent to the object by syntactically sending them to the object pointer.
\ The normal syntax is
\ ObjPtr ZZZ class_is someClass
\ Thereafter, any messages sent to zzz are early-bound to the object that
\ zzz points to at the time the message executes.
\ If you need to declare the object pointer before the class exists, use
\ SET_TO_CLASS once the class is defined, thus:
\
\ :class SOMECLASS super{ object }
\
\ ' someOP set_to_class someClass
\
\ etc.
: (ToOP) { ^obj OPcfa \ OPcl -- }
^obj nilP = \ If we're storing nil, anything goes
NIF OPcfa 4+ @abs -> OPcl
^obj 6 - @abs OPcl <>
IF \ Mismatch. We give some useful(?) info.
cr ^obj obj> .id ." -> " OPcfa .id
87 die
THEN
THEN
^obj OPcfa ! ;
:f ToObjPtr
state
IF lit-addr postpone (toOP) ELSE (toOP) THEN ;f
: CLASS_IS \ ( --< class > )
?exec ' chkClass here 4- reloc! ;
: SET_TO_CLASS { ^objPtr \ ^cl --< class > }
' -> ^cl
^objPtr hdlr -62 <> ?error 85 \ "That isn't an ObjPtr"
\ Now if "class" is an imported word, we change the handler code
\ to "imported class". This is normally done when the module
\ is compiled, but it may not be yet, since we probably
\ want to refer to the ObjPtr in the module.
^cl hdlr -92 = IF -90 ^cl 2- w! ELSE ^cl chkClass drop THEN
^cl ^objPtr 4+ reloc! ;
\ If you are late-binding in a loop, it can be much faster if you do the bind
\ just once, then reuse the resulting cfa each time in the loop. This way
\ you only have to perform the method search once. To bind initially and get
\ the cfa, use
\ BIND_WITH ( ^obj --<selector> ^obj-modified cfa )
\ Usage: (saveCfa and ^obj-mod are values or locals)
\ (get object's address) bind_with someSelector: -> saveCfa -> ^obj-mod
\ (in the loop) ^obj-mod saveCfa ex-method
\ The use of the modified object address is a bit obscure, and is related to
\ multiple inheritance. The method you actually end up binding to may be in
\ one of the superclasses, and the ivars for that superclass may not start at
\ the beginning of the object. The modified object address is the start of
\ the ivars for the superclass, which is the address the method needs.
\ Note also that the method may turn out to be in a module, so when you have
\ finished you should put ?unHoldMod to free up the module.
: (BWITH) \ ( ^obj selID -- ^obj-modified cfa )
over ?>class findm >r + r> ;
: BIND_WITH \ ( ^obj --<selector> ^obj-modified cfa )
getSelect postpone literal
postpone (bwith) ; immediate
\ ===================================
:class OBJECT super{ meta }
:m CLASS: ^base ?>class ?>classinMod ;m
:m .ID: ^base obj> .id ;m
:m .CLASS: ^base >classCfa .id ;m
:m ADDR: inline{ obj}
^base ;m
:m ABS: ^base ;m \ Included for Neon/Yerk compatibility
:m LENGTH: \ ( -- len ) Gets total length of object.
objlen ;m
(* Here are two methods which operate between this object and another of
the same class. Note we don't check that the passed-in object is actually
of the same class, since it could be a subclass but still be safe to use
here.
*)
:m COPYTO: \ ( ^obj -- ) Copies the ivar part of the passed-in object
\ to self.
^base dup (^dlen) w@ aligned_move ;m
:m =?: \ ( ^obj -- b ) Returns true if the ivar part of the passed-in
\ object is identical to self.
^base dup (^dlen) w@ (s=) ;m
(* The following methods need to be defined for all objects.
We give them their default definitions here.
*)
:m CLASSINIT: ;m \ Our standard constructor method. Called automatically
\ whenever an object is created.
:m DEEP_CLASSINIT: \ Also does classinit: on all nested ivars. Use for
\ totally (re-)initializing an object.
^base -> newObject
class: self ifa displace 0 0
ivSetup ?unholdMod ;m
(* RELEASE: is our standard destructor method. Any objects that
allocate heap storage will redefine this appropriately.
Our convention is that an object will release ALL its
storage when it gets a release: message. Other methods
can be provided to partly release storage, as needed.
*)
:m RELEASE: inline{ } ;m
:m DUMP:
.id: self ." class: " .class: self
^base objlen dump ;m
:m PRINT: \ Used for a formatted display, if appropriate.
\ Default is just a dump.
dump: self ;m
;class
\ Bytes is used as the allocation primitive for basic classes
: BYTES { numBytes \ svRec? -- }
?class
rec? -> svRec? true -> rec? \ Don't want an object header here
['] object ivDef
numBytes ^class dfa w+!
svRec? -> rec? ;
(* =================== Local objects ======================
Syntax:
: aWord { loc1 loc2 -- } \ Locals are optional, of course
temp
{ var v1
int i1
string s
}
Or you can use temp{ ... } if you prefer.
As the syntax is quite similar to a list of ivars of a class, we actually
implement the temp objects as though they're the ivars of a dummy class
(which we uncreatively call Dummy). This is just a convenience during
the compilation of a defn with temp objects. It allows us to define them
and keep them visible during the compilation of the definition, while mainly
using existing code for ivar access. We don't need these ivar dic entries
once the defn is finished, so we actually put them high in the dictionary
out of the way of the defn we're compiling. At the end of the defn,
we reinitialize Dummy's ivar link ready for next time.
*)
getSelect release: constant releaseID
:class DUMMY super{ object }
;class
' dummy ifa @ constant dummyIfa
: RESETTEMPS
dummyIfa ['] dummy ifa !
0 ['] dummy dfa ! \ clear dlen and xwid
;
\ Note we don't have to worry about the mfa since Dummy never gets
\ its own methods.
(*
InitTemps is called when we're compiling the prologue for a definition
with temp objects. It compiles a call to make_obj for each object, so
that they're properly initialized. Note we can't just call make_obj once
using class Dummy, since its ivar list is wiped out after each defn
with temp objects, so at run time it won't have any! But we don't need
Dummy at run time anyway - we only need the "ivars" which are the
temp objects themselves.
*)
: 1TEMP ( ^iclass ioffs -- )
locReg + make_obj ;
:f INITTEMPS { \ infa -- }
['] dummy ifa displace -> infa
BEGIN
infa @ 0<
WHILE
infa ^iclass lit-addr
infa ioffs postpone literal
postpone 1temp
infa ^nextivar -> infa
REPEAT ;f
(*
ReleaseTemps is called back from Handlers when it's compiling an exit.
It compiles a release: xxx for all temp objects. Because of the way
we've defined release: in class Object, for simple objects no code will
actually be generated.
Note we mustn't call resetTemps here since this might be an EXIT, not
the final semicolon. We leave calling resetTemps till a new temp{ comes
up.
*)
: RELEASETEMPS { \ infa -- }
['] dummy ifa displace -> infa
BEGIN
infa @ 0<
WHILE
infa ^iclass 0EXIT \ shouldn't happen, actually
releaseID infa ivFindM drop
infa ioffs bind_to_tmpObj \ compile release:
infa ^nextivar -> infa
REPEAT
;
: }TEMP
130 ?pairs
['] } ! \ restore old action for "}"
-> ^class -> state -> cstate -> DP \ restore other things
tmpObjs dlen 8 + -> frameSize \ work out frame size
local? NIF \ compile prologue unless we're in
PLentry initTemps \ a local section (then it gets done
THEN \ by :LOC)
['] releaseTemps -> relTmps \ for Handlers callback at exit time
;
: TEMP{ immediate
(* First we have to allocate an internal local variable as a frame pointer.
There are 4 situations. There may or may not already be locals, and
we may or may not be in a local section. Note we can be in a local
section even if there aren't already locals, since the purpose of the
local section might be just to establish a section for these temp objects.
If there are already locals, we just add another. If we're not in a
local section we need to recompile the entry sequence (done by PLentry)
since the number of regs to be saved and set up is different. But if
we're in a local section, we don't have to recompile since we haven't
called PLentry yet, so we just add the extra local. If there aren't any
locals already, we just call initLocs which sets them up, before adding
the new one.
*)
resetTemps
#PL IF
local? NIF PLentry_addr -> DP THEN
ELSE
initLocs \ No locs before, so set up for them now
THEN
local? IF -1 -> local? THEN \ If in a local section, setting local?
\ to -1 means we've defined the locals
\ so can't do it again
" x " here place here addToParmList
(* next we save DP and move halfway up in the free dic space - we'll put
the "ivar dic entries" for the temp objs there - we don't need them
after the defn is compiled.
*)
here room 2/ ++> DP align-dp
cstate true -> cstate
state
^class
['] } @ \ save old action for "}"
['] }temp -> } \ "}" will now be same as }temp
130 \ for ?pairs
['] dummy dup -> ^class \ local objs will look like ivars of Dummy
-> tmpObjs \ this will enable finding them
postpone [ \ stop compiling
;
: TEMP gobble{ postpone temp{ ; immediate
(* ================= Records and unions ====================
Syntax:
record <name> \ The name is optional
{ var v1
int i1
string s
}
union <name> \ The name is optional
{ var v1
int i1
string s
}
Or you can use record{ ... } or union{ ... } if you prefer, if it's
unnamed. The similarity of syntax to temp objects is quite deliberate.
But any similarity to Your Favorite Language is entirely accidental. Well
actually it's not, but I think this syntax is as good as any, and probably
more readable for folks coming from C-land.
unions can be nested within records and vice versa.
*)
: SVREC rec? union? unionOffs ;
: RSTREC -> unionOffs -> union? -> rec? ;
: ?HANDLE_NAME { \ sv_>in sv_^class sv_rec? -- }
>in @ -> sv_>in ^class -> sv_^class rec? -> sv_rec?
Mword count " {" s=
NIF \ we've got a name for the record
true -> rec? \ must do this before defining the name "object"
sv_>in >in !
['] object ivDef
sv_rec? -> rec? sv_^class -> ^class
gobble{ \ "{" must follow
THEN
;
: }RECORD
131 ?pairs rstRec
['] } 4+ ! \ restore old action for "}"
( false -> rec? ) ;
: RECORD{
?class \ must be compiling a class
['] } 4+ @ \ save old action for "}"
['] }record -> } \ "}" will now be same as }record
svRec \ save parameters for any existing record/union
131 \ for ?pairs
true -> rec? false -> union? ;
: RECORD
?handle_name
record{ ;
: }UNION
132 ?pairs
unionOffs ^class dfa w!
rstRec
['] } 4+ ! ; \ restore old action for "}"
: UNION{
?class \ must be compiling a class
['] } 4+ @ \ save old action for "}"
['] }union -> } \ "}" will now be same as }union
svRec \ save record/union parameters
132 \ for ?pairs
true -> rec? true -> union?
^class dfa w@ -> unionOffs ;
: UNION
?handle_name
union{ ;
(* ================= Static ivars ====================
Syntax:
static
{ var v1
int i1
string s
}
Or you can use static{ ... } if you prefer.
These are like static class variables in C++ - they belong to the class,
not the object, and thus are shared by all objects of the class. We
allocate each ivar in the dictionary right after its ivar header.
*)
: }STATIC
133 ?pairs
['] } 4+ ! \ restore old action for "}"
false -> static? ;
: STATIC{
?class \ must be compiling a class
['] } 4+ @ \ save old action for "}"
['] }static -> } \ "}" will now be same as }static
133 \ for ?pairs
true -> static? ;
: STATIC
gobble{ static{ ;
\ ==========================================
\ CL1 is our first cleanup word - called on an abort. Resets things
\ to normal. Later cleanup words do their special stuff, then call CL1.
: CL1
(;cl) clrComp ['] (}) -> }
resetTemps false -> rec? false -> union?
0 -> extraFind
0 -> bufPtr
DP hiDP umax -> DP
false -> case_in_names?
;
' cl1 -> abortVec
load Struct
\ ==========================================
(* Normally we don't get here. In order to do various tests on classes,
we comment out the <" Struct and run various parts of the torture test
stuff following.
*)
+echo
:class VAR super{ object }
4 bytes data
:m CLEAR:
inline{ 0 obj !}
0 ^base ! ;m
:m GET:
inline{ obj @}
^base @ ;m
:m PUT:
inline{ obj !}
^base ! ;m
:m GETT: ^base @ ;m
:m PUTT: ^base ! ;m
:m +:
inline{ obj +!}
^base +! ;m
:m -:
inline{ obj -!}
^base -! ;m
:m ->:
inline{ @ obj !}
chksame get: var put: self ;m
:m TEST: db ;m
mlocal LOCTEST: { aa \ bb cc -- }
:m AAA: aa -> bb ;m
:mloc LOCTEST:
db aaa: self cc -> bb 1234 drop ;mloc
:m PRINT:
^base @ . ;m
:m CLASSINIT: $ 123 put: self ;m
;class
:class BYTE super( object )
1 bytes data
:m CLEAR:
inline{ 0 obj c!}
0 ^base c! ;m
:m GET:
inline{ obj c@x}
^base c@x ;m
:m UGET:
inline{ obj c@}
^base c@ ;m
:m PUT:
inline{ obj c!}
^base c! ;m
:m ->:
inline{ c@ obj c!}
chksame c@ put: self ;m
:m PRINT:
^base c@ . ;m
:m CLASSINIT: 9 put: self ;m
;class
key!
:class BOOL super( byte )
:m GET:
inline{ obj c@x}
^base c@x ;m
:m PUT:
inline{ 0<> obj c!}
0<> ^base c! ;m
:m SET:
inline{ true obj c!}
true ^base c! ;m
:m PRINT:
get: self IF ." true" ELSE ." false" THEN ;m
:m CLASSINIT: clear: self ;m
;class
:class BARRAY super{ object } 1 indexed
:m AT: \ ( index -- n )
inline{ ix c@}
^elem1 c@ ;m
:m TO: \ ( n index -- )
inline{ ix c!}
^elem1 c! ;m
:m ^ELEM: \ ( index -- addr )
inline{ ix}
^elem1 ;m
:m FILL: \ ( value -- ) Fills all elements with value.
idxbase limit 2* bounds
?DO dup i c! LOOP drop ;m
:m WIDTH: 1 ;m \ Faster than the default in Object
:m GETELEM: \ ( addr -- n ) Fetches one element at addr
c@x ;m
;class
\ Testing static ivars
:class SIVTEST super{ var }
public
static
{ var V1
bool B1
byte B2
10 barray BB
}
bool BLOC
var VLOC
:m QQ: db get: v1 get: b1 get: b2 4 at: bb
get: vloc ;m
;class
sivtest zzz
sivtest sss
objPtr myop class_is sivtest
: QQQ db get: ivar> b2 in_class sivtest
get: ivar> v1 in_class sivtest
sss get: ivar> bloc in class_as> sivtest ;
key!
:class HAHA super{ object }
sivtest IVsss
:m QQ: db get: ivar> vloc IN ivsss ;m
;class
haha hh
: WWW temp { sivtest mysiv }
db get: ivar> vloc IN mysiv
mysiv -> myop
get: ivar> vloc IN myop ;
+echo
\ Testing record{
:class VAR+ super{ var }
:m QQ: db
get: [self] \ should make class general
get: [ self ]
db
;m
;class
var+ VVV
key!
+echo
:class RECTEST super{ object }
var vv
record RR
{ var v1
bool b1
3 barray bbb
byte dummyToMakeAddrOdd
union { byte b2
var v2
record { byte bb1
byte bb2 }
}
var v3
}
:m TEST:
db get: v1 put: b1 get: b2 get: v2 get: bb1 get: bb2 get: v3
;m
;class
recTest rrr
test: rrr
\ Testing temp objects
: q db
temp
{ var v1
var v2
}temp
v1 v2
get: v1 get: v2 db ;
:class INT super( object )
2 bytes data
:m CLEAR:
inline{ 0 obj ! }
0 ^base ! ;m
:m UGET:
inline{ obj w@ }
^base w@ ;m
:m GET:
inline{ obj w@x }
^base w@x ;m
:m IPUT: ^base w! ;m
:m DISP:
inline{ obj 2+ @ } ;m
:m PUT:
inline{ obj w! }
^base w! ;m
:m MOVE:
inline{ obj 4+ w@ obj w! } ;m
:m +: inline{ obj w+! }
^base w+! ;m
:m ->:
inline{ w@ obj w! }
db chksame 1234 drop get: int put: self ;m
:m ++>:
inline{ w@ obj w+! }
db chksame uget: int +: self ;m
:m .ID: ." haha" ;m
:m TEST:
1234 drop .id: super ;m
:m CLASSINIT: db $ 456 put: self ;m
;class
:class CC super{ byte int var bool }
:m TEST:
db uget: self \ offs should be 0
+: self \ offs should be 4
set: self ;m \ offs should be A
:m TEST1:
db set: self
get: super> bool \ should get -1
get: super
;m
:m classinit: db ;m
;class
cc CCC
:class STRANGE super{ object }
var VV
byte BB
:m GET: get: vv get: bb ;m
:m PUT: put: bb put: vv ;m
;class
:class ARRAY super( object ) 4 indexed
\ 8 bytes data \ Comment out to check collapsing of embedded objs
:m ^ELEM: \ ( index -- addr )
^elem4 ;m
:m QQQ: inline{ ix } ;m
:m AT: \ ( index -- n )
inline{ ix @ }
^elem4 @ ;m
:m ATT: ^elem @ ;m \ As for AT:, but not inline
\ and uses unoptimized ^elem
:m TO: \ ( n index -- )
inline{ ix ! }
^elem4 ! ;m
:m +TO: \ ( n index -- )
inline{ ix +! }
^elem4 +! ;m
:m -TO: \ ( n index -- )
inline{ ix -! }
^elem4 -! ;m
:m FILL: \ ( value -- ) Fills all elements with value.
idxbase limit 4* bounds
DO dup i ! 4 +LOOP drop ;m
:m EXEC: \ ( index -- ) execute the cfa, by jumping there.
inline{ ix ex}
^elem: self execute ;m
:m TEST:
exec: self ;m
:m ATEST:
1 at: self ;m
;class
var VV
:class XXX super( object )
var VV1
var VV2
3 array AA
:m TEST: inline{ 9 putt: vv2 get: vv2 at: aa} get: vv2 ;m
:m TESTT: db 2 at: aa get: vv1 get: vv2 ;m
:m ZZ: inline{ get: vv2 get: vv} get: vv2 ;m
:m CLASSINIT: 3 0 do $ 777 i to: aa loop ;m
;class
:class YYY super{ xxx }
;class
:class ZZZ super{ object }
xxx X1
yyy Y1
:m TEST: db ;m
;class
zzz Z1
:class QQQ super( object )
xxx XXX1
xxx XXX2
:m TEST: zz: xxx1 zz: xxx2 zz: xxx1 ;m
;class
objPtr OO class_is xxx
xxx xxxx
qqq qqqq
xxxx -> oo
:class BLOGGS super( object )
var VV
4 array AA
:m TEST: db 2 + i - at: aa ;m
;class
bloggs BB
:class MULT super( var int array )
:m MTEST: uget: super 999 1 to: self ;m
:m MAT: at: self ;m
;class
objPtr OO class_is mult
objPtr OOO class_is int
:class IVXX super( object )
10 bytes data2
int i1
int i2
130 bytes qqqq \ Include to check >128 distance
\ index addressing of array qwert
9 array qwert
:m ITEST:
get: i1 uget: i2 66 put: i2
99 3 to: qwert 1234 drop 3 at: qwert
addr: i2 ['] ooo ! ;m
:m GETQWERT:
addr: qwert ;m
;class
int ii
3 mult mm
ivxx iv
mm -> oo
itest: iv . . .
mtest: mm .
88 iput: mm \ Note: get: mm will bind to the var, but uget: mm
\ will bind to the int and give 88.
\ A further test - Doug H found this bug:
:class POINT super{ object }
int Y \ Vertical coordinate
int X \ Horizontal coordinate
;class
:class RECT super{ object }
point TOPL
point BOTR
;class
:class test1 super{ object }
20 array a
:m classinit:
55 0 to: a ;m
:m to: to: a ;m
:m at: at: a ;m
;class
:class test3 super{ rect test1 }
:m classinit:
[ 1 -> supers_to_skip ] classinit: super
;m
;class
test3 t3
: q db getqwert: iv 3 swap at: ** ; \ Should give 99
: qq db 1 at: mm ; \ Should give 999
: qqq db 1 mat: mm ; \ Should give 999
: qqqq db 1 mm at: mult ; \ Should give 999
: z db 1 mm at: ** ; \ Should give 999
: zz db 1 mm at: array ; \ Should fail
: y db 1 at: oo ; \ Should give 999
: yy db 1 mat: oo ; \ Should give 999
: yyy db uget: mm ; \ Should optimize & give 88
: yyyy db addr: mm addr: oo ; \ Both numbers shd be same
: yyyyy db uget: ooo ; \ Should give 66
: yyyyyy db 0 at: t3 ; \ Should give 55
: ?CHK <> abort" check FAILED!!!" ;
q 99 ?chk
qq 999 ?chk
qqq 999 ?chk
qqqq 999 ?chk
z 999 ?chk
y 999 ?chk
yy 999 ?chk
yyy 88 ?chk
yyyy ?chk
yyyyy 66 ?chk
yyyyyy 55 ?chk
\ torture tests WORKED! INCREDIBLE!! CONGRATULATIONS!!!
\ (but remember to check that ZZ gives a "can't use indexed method" error)
key!
:class MULTX super( mult )
:m ntest: db 444 1 to: super ;m
;class
4 multx MX
\ ivar clash test
:class CLASH super( object )
2 array A1
3 array A2
:m TEST: db 77 1 to: a1 66 0 to: a2 1 at: a1 ;m \ Shd give 77
;class
clash CC